home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 September / Macworld (1997-09).dmg / Shareware World / Utilities / Text Processing / AlphaLite.6.52 / Tcl / SystemCode / marks.tcl < prev    next >
Text File  |  1996-08-15  |  4KB  |  188 lines
  1.  
  2. # ================================================================================
  3. # Clear marks for front window.
  4. #================================================================================
  5.  
  6. proc gotoFileMark {} {
  7.     set text [getSelect]
  8.     if {[string length $text] && ([string length $text] < 20)} {
  9.         gotoMark [listpick -p "Mark?" -L [list $text] [getNamedMarks -n]]
  10.     } else {
  11.         gotoMark [listpick -p "Mark?" [getNamedMarks -n]]
  12.     }
  13. }
  14.  
  15.  
  16. proc markFile {} {
  17.     global    mode
  18.     
  19.     if {[llength [getNamedMarks -n]]} {
  20.         if {[askyesno -c "Clear old marks?"]} {
  21.             clearFileMarks
  22.         }
  23.     }
  24.     ${mode}MarkFile
  25. }
  26.  
  27. proc clearFileMarks {} {
  28.     set win [car [winNames -f]]
  29.     
  30.     foreach mk [getNamedMarks -n] {
  31.         removeNamedMark -n $mk -w $win
  32.     }
  33. }
  34.  
  35.  
  36. proc sortMarksFile {} {
  37.     if {[askyesno "Really sort all marks?"] != "yes"} {return}
  38.  
  39.     set nm [car [winNames -f]]
  40.     
  41.     set mks {}
  42.     foreach mk [getNamedMarks] {
  43.         removeNamedMark -n [lindex $mk 0] -w [lindex $mk 1]
  44.         lappend mks $mk
  45.     }
  46.  
  47.     foreach mk [lsort $mks] {
  48.         set name [lindex $mk 0]
  49.         set disp [lindex $mk 2]
  50.         set pos [lindex $mk 3]
  51.         set end [lindex $mk 4]
  52.         
  53.         setNamedMark $name $disp $pos $end
  54.     }
  55. }
  56.  
  57. # From Mark Nagata
  58. proc zeroadd {num} {
  59.     set mx [maxPos]
  60.     set len [string length $mx]
  61.     set num [format "%0${len}d" $num]
  62.     return $num
  63. }
  64.  
  65. proc orderMarks {} {
  66.     if {[askyesno "Really reorder all marks?"] != "yes"} {return}
  67.  
  68.     set nm [car [winNames -f]]
  69.     
  70.     set wks {}
  71.     foreach mk [getNamedMarks] {
  72.         removeNamedMark -n [lindex $mk 0] -w $nm
  73.         set name [lindex $mk 0]
  74.         set disp [lindex $mk 2]
  75.         set pos [lindex $mk 3]
  76.         set end [lindex $mk 4]
  77.         set pos [zeroadd $pos]
  78.         set wk [list $pos $disp $name $end]
  79.         lappend wks $wk
  80.     }
  81.  
  82.     foreach wk [lsort $wks] {
  83.         set name [lindex $wk 2]
  84.         set disp [lindex $wk 1]
  85.         set pos [lindex $wk 0]
  86.         set end [lindex $wk 3]
  87.         
  88.         setNamedMark $name $disp $pos $end
  89.     }
  90. }
  91.  
  92.  
  93. # ================================================================================
  94. # Simple mark stack implementation
  95. # ================================================================================
  96. proc pushMark {} {
  97.     global markStack
  98.     global markName
  99.     
  100.     set name mark$markName
  101.     incr markName
  102.     createTMark $name [getPos]
  103.     set fileName [car [winNames -f]]
  104.     set markStack [linsert $markStack 0 [list $fileName $name]]
  105.     message [concat Mark [llength $markStack] Pushed]
  106. }
  107.  
  108. proc popMark {} {
  109.     global markStack
  110.     if {[llength $markStack] == "0"} {
  111.         message "The mark stack is empty!"
  112.         return
  113.     }
  114.     set mark [lindex [lindex $markStack 0] 1]
  115.     set markStack [lreplace $markStack 0 0]
  116.     if {[catch {gotoTMark $mark}]} {
  117.         popMark
  118.         return
  119.     }
  120.     message [concat Mark [expr [llength $markStack] + 1] Popped]
  121. }
  122.  
  123.     
  124. # Returns 'list' minus all top-level elements matching 'pat'.
  125. # Used in 'closeHooks' to prune the mark stack.
  126. proc removePat {list pat} {
  127.     while 1 {
  128.         set ind [lsearch $list $pat]
  129.         if {$ind == "-1"} {return $list}
  130.         set list [lreplace $list $ind $ind]
  131.     }
  132. }
  133.  
  134.  
  135.  
  136.  
  137. #================================================================================
  138. # Only works while in same file.
  139. #================================================================================
  140.  
  141. proc pointToRegister {} {
  142.     message "Letter?"
  143.     createTMark [set c [getChar]] [getPos]
  144.     message "Register '$c'"
  145. }
  146.  
  147.  
  148. proc jumpToRegister {} {
  149.     message "Letter?"
  150.     gotoTMark [set c [getChar]]
  151.     message "Register '$c'"
  152. }
  153.  
  154.  
  155.  
  156. #================================================================================
  157.  
  158. proc fileMark {} {
  159.     set nm [car [winNames -f]]
  160.     
  161.     global mks
  162.     set mks [getNamedMarks -n]
  163.     
  164.     set res [statusPrompt "Goto mark: " markComp]
  165.     unset mks
  166.     if {[string length $res]} {
  167.         gotoMark $res
  168.     }
  169. }
  170.  
  171. proc markComp {curr c} {
  172.     global mks
  173.     if {$c != "\t"} {return $c}
  174.  
  175.     set matches {}
  176.     foreach w $mks {
  177.         if {[string match "$curr*" $w]} {
  178.             lappend matches $w
  179.         }
  180.     }
  181.     if {![llength $matches]} {
  182.         beep
  183.     } else {
  184.         return [string range [largestPrefix $matches] [string length $curr] end]
  185.     }
  186.     return ""
  187. }
  188.